home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / print.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-08-17  |  16.8 KB  |  652 lines
  1. /* ******************************************************************** */
  2. /*  print.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Output functions                                            */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * Change Log:
  9.  *   Version 1, April 1989
  10.  *     Added write function - RJB
  11.  *     Fixed results of prin and write - JPff
  12.  *     Added printing of macros - JPff
  13.  *     some classes - RJB
  14.  */
  15.  
  16. #include <stdio.h>
  17. #include <string.h>
  18. #include <ctype.h>
  19. #include "defs.h"
  20. #include "structs.h"
  21. #include "funcalls.h"
  22.  
  23. #include "error.h"
  24. #include "global.h"
  25.  
  26. #include "vectors.h"
  27. #include "table.h"
  28. #include "bootstrap.h"
  29.  
  30. #include "modboot.h"
  31. #include "ngenerics.h"
  32.  
  33. #if (defined(MACHINE_SYSTEMV) || defined(MACHINE_BSD))
  34.  
  35. static char linebuff[200];
  36. FILE* current_output;
  37.  
  38. #define LINEBUFF()        (linebuff)
  39. #define CURRENT_OUTPUT() (current_output)
  40.  
  41. #endif
  42.  
  43. #ifdef MACHINE_ANY
  44.  
  45. static char linebuff[200];
  46. FILE* current_output;
  47.  
  48. #define LINEBUFF()        (linebuff)
  49. #define CURRENT_OUTPUT() (current_output)
  50.  
  51. #endif
  52.  
  53. #ifdef MACHINE_TITAN
  54.  
  55. static char linebuff[PROCESSORS][200];
  56. FILE* current_output[PROCESSORS];
  57.  
  58. #define LINEBUFF()       (linebuff[THIS_PROCESS])
  59. #define CURRENT_OUTPUT() (current_output[THIS_PROCESS])
  60.  
  61. #endif
  62.  
  63. /*
  64.  * Reconstructable symbol printer by rjb...
  65.  */
  66.  
  67. static void print_id(char *id, FILE *stream)
  68. {
  69.   extern int escaped_id(char *);
  70.  
  71.   if (escaped_id(id)) {
  72.     putc('|', stream);
  73.     while (*id) {
  74.       if (*id == '\\' || *id == '|')  putc('\\', stream);
  75.       putc(*id++, stream);
  76.     }
  77.     putc('|', stream);
  78.   }
  79.   else {
  80.     fputs(id, stream);
  81.   }
  82. }
  83.  
  84. /* do we need to escape this id when printing?
  85.  * yes if (1) it contains a dodgy character
  86.  *        (2) it is the id of zero length
  87.  *        (3) it starts with the syntax of a number
  88.  *
  89.  * ASCII dependent
  90.  */
  91.  
  92. /* Redundant copy---see parser.lex */
  93. #if 0
  94. static int escaped_id(char *id)
  95. {
  96.   int i;
  97.  
  98.   for (i = 0; id[i]; i++)
  99.     if (id[i] < 32 || id[i] > 126 || id[i] == '|' || id[i] == '\\') return 1;
  100.  
  101.   if (strpbrk(id, "|\\#()\"',;` ") ||
  102.       id[0] == 0 ||        /* zero length id */
  103.       isdigit(id[0]) ||                    /* 123 */
  104.       (id[0] == '.' && id[1] && isdigit(id[1])) ||    /* .123 */
  105.       ((id[0] == '+' || id[0] == '-') &&
  106.     id[1] && (isdigit(id[1]) ||            /* +123 */
  107.               (id[1] == '.' && id[2] && isdigit(id[2]))))) /* +.123 */
  108.     return 1;
  109.   else
  110.     return 0;
  111. }
  112. #endif
  113.  
  114. LispObject Fn_prin_internal(LispObject*);
  115.  
  116. /* 
  117.  * Hacked internal writer... 
  118.  */
  119.  
  120. EUFUN_1( Fn_write_internal, form)
  121. {
  122.   int i;
  123.   LispObject ans = form;
  124.  
  125.   switch (typeof(form)) {
  126.   case NULL:
  127.     sprintf(LINEBUFF(),"#<collected-object: %x %x>",
  128.         form->HUNK.hunk_size,
  129.         (int) form);
  130.     fputs(LINEBUFF(),CURRENT_OUTPUT());
  131.     break;
  132.   case TYPE_NULL:
  133.     fputs("()",CURRENT_OUTPUT());
  134.     break;
  135.   case TYPE_INT:
  136.     sprintf(LINEBUFF(),"%d",intval(form));
  137.     fputs(LINEBUFF(),CURRENT_OUTPUT());
  138.     break;
  139.   case TYPE_FLOAT:
  140.     {
  141.       sprintf(LINEBUFF(),"%lf",form->FLOAT.fvalue);
  142.       fputs(LINEBUFF(),CURRENT_OUTPUT());
  143.     }
  144.     break;
  145.   case TYPE_COMPLEX:
  146.     fputs("#C(",CURRENT_OUTPUT());
  147.     EUCALL_1(Fn_write_internal,(form->COMPLEX).real);
  148.     putc(',',CURRENT_OUTPUT());
  149.     form = ARG_0(stackbase);
  150.     EUCALL_1(Fn_write_internal,(form->COMPLEX).imaginary);
  151.     putc(')',CURRENT_OUTPUT());
  152.     break;
  153.   case TYPE_CHAR:
  154.     if (form == q_eof) {
  155.       fprintf(CURRENT_OUTPUT(),"<<EOS>>");    
  156.       break;
  157.     }
  158.     putc('#', CURRENT_OUTPUT());
  159.     putc('\\', CURRENT_OUTPUT());
  160.     switch ((form->CHAR).code) {
  161.     case ' ':
  162.       fputs("space", CURRENT_OUTPUT());
  163.       break;
  164.     case '\n':
  165.       fputs("newline", CURRENT_OUTPUT());
  166.       break;
  167.     case '\r':
  168.       fputs("return", CURRENT_OUTPUT());
  169.       break;
  170.     case '\t':
  171.       fputs("tab", CURRENT_OUTPUT());
  172.       break;
  173.     default:
  174.       if (!isprint((form->CHAR).code)) {
  175.     sprintf(LINEBUFF(), "%03o", (form->CHAR).code);
  176.     fputs(LINEBUFF(),CURRENT_OUTPUT());
  177.       }
  178.       else putc((form->CHAR).code,CURRENT_OUTPUT());
  179.       break;
  180.     }
  181.     break;
  182.   case TYPE_SYMBOL:
  183.     if (form == nil)
  184.       fprintf(CURRENT_OUTPUT(),"()");
  185.     else 
  186.       print_id(stringof(form->SYMBOL.pname),CURRENT_OUTPUT());
  187.     break;
  188.   case TYPE_STRING:
  189.     putc('"',CURRENT_OUTPUT());
  190.     sprintf(LINEBUFF(),"%s",stringof(form));
  191.     for (i = 0; LINEBUFF()[i] != 0; i++) {
  192.       switch (LINEBUFF()[i]) {
  193.       case '\n':
  194.     putc('\\', CURRENT_OUTPUT());
  195.     putc('n', CURRENT_OUTPUT());
  196.     break;
  197.       case '\r':
  198.     putc('\\', CURRENT_OUTPUT());
  199.     putc('r', CURRENT_OUTPUT());
  200.     break;
  201.       case '\t':
  202.     putc('\\', CURRENT_OUTPUT());
  203.     putc('t', CURRENT_OUTPUT());
  204.     break;
  205.       case '\f':
  206.     putc('\\', CURRENT_OUTPUT());
  207.     putc('p', CURRENT_OUTPUT());
  208.       case '"':
  209.     putc('\\', CURRENT_OUTPUT());
  210.     putc('"', CURRENT_OUTPUT());
  211.     break;
  212.       case '\\':
  213.     putc('\\', CURRENT_OUTPUT());
  214.     putc('\\', CURRENT_OUTPUT());
  215.     break;
  216.       default:
  217.     putc(LINEBUFF()[i], CURRENT_OUTPUT());
  218.     break;
  219.       }
  220.     }
  221.     putc('"',CURRENT_OUTPUT());
  222.     break;
  223.   case TYPE_CONS:
  224.     putc('(',CURRENT_OUTPUT());
  225.     EUCALL_1(Fn_write_internal, CAR(form));
  226.     form = ARG_0(stackbase);
  227.     while (is_cons(CDR(form))) {
  228.       putc(' ',CURRENT_OUTPUT());
  229.       form = CDR(form);
  230.       ARG_0(stackbase) = form;
  231.       EUCALL_1(Fn_write_internal,CAR(form));
  232.       form = ARG_0(stackbase);
  233.     }
  234.     if (CDR(form) == nil) putc(')',CURRENT_OUTPUT());
  235.     else {
  236.       putc(' ',CURRENT_OUTPUT());
  237.       putc('.',CURRENT_OUTPUT());
  238.       putc(' ',CURRENT_OUTPUT());
  239.       EUCALL_1(Fn_write_internal, CDR(form));
  240.       putc(')',CURRENT_OUTPUT());
  241.     }
  242.     break;
  243.   case TYPE_I_FUNCTION:
  244.     {
  245.       LispObject body;
  246.       /*
  247.       Env env;
  248.       */
  249.  
  250.       fputs("#<interpreted-function: (lambda ",CURRENT_OUTPUT());
  251.       EUCALL_1(Fn_prin_internal, (form->I_FUNCTION).bvl);
  252.       form = ARG_0(stackbase);
  253.       body = form->I_FUNCTION.body;
  254.       while ( body != nil ) {
  255.     fprintf(CURRENT_OUTPUT()," ");
  256.     STACK_TMP(CDR(body));
  257.     EUCALL_1(Fn_prin_internal, CAR(body));
  258.     UNSTACK_TMP(body);
  259.       }
  260.       putc(')',CURRENT_OUTPUT());
  261.  
  262. #if 0
  263.       for (env = form->I_FUNCTION.env; env != NULL; env = env->next) {
  264.     fprintf(CURRENT_OUTPUT()," %s=",stringof(env->variable->SYMBOL.pname));
  265.     EUCALL_1(Fn_prin_internal,env->value);
  266.       }
  267. #endif
  268.  
  269.       fprintf(CURRENT_OUTPUT()," @ %s>",
  270.           stringof(form->I_FUNCTION.home->I_MODULE.name->SYMBOL.pname));
  271.     }
  272.     break;
  273.  
  274.    default:
  275.     {
  276.       EUCALL_1(Fn_prin_internal, form);
  277.     }
  278.   }
  279.   return ans;
  280. }
  281. EUFUN_CLOSE
  282.  
  283. EUFUN_2( Fn_write, form, stream)
  284. {
  285.   if (stream==NULL) CURRENT_OUTPUT() = (StdOut->STREAM).handle;
  286.   else CURRENT_OUTPUT() = (stream->STREAM).handle;
  287.   return Fn_write_internal(stackbase);
  288. }
  289. EUFUN_CLOSE
  290.  
  291. EUFUN_1( Fn_prin_internal, form)
  292. {
  293.   LispObject ans = form;
  294.  
  295.   if (form==NULL) {
  296.     fprintf(CURRENT_OUTPUT(),"<<NULL>>");
  297.     return ans;
  298.   }
  299.  
  300.   STACK_TMP(ans);
  301.  
  302.   switch (typeof(form)) {
  303.   case NULL:
  304.     sprintf(LINEBUFF(),"#<collected-object: %x %x>",
  305.         form->HUNK.hunk_size,
  306.         (int) form);
  307.     fputs(LINEBUFF(),CURRENT_OUTPUT());
  308.     break;
  309.   case TYPE_NULL:
  310.     fprintf(CURRENT_OUTPUT(),"()");
  311.     break;
  312.   case TYPE_WEAK_WRAPPER:
  313.     fprintf(CURRENT_OUTPUT(),"#<weak-wrapper: ");
  314.     EUCALL_1(Fn_prin_internal,form->WEAK_WRAPPER.object);
  315.     fprintf(CURRENT_OUTPUT(),">");
  316.     break;
  317.   case TYPE_INT:
  318.     sprintf(LINEBUFF(),"%d",intval(form));
  319.     fputs(LINEBUFF(),CURRENT_OUTPUT());
  320.     break;
  321.   case TYPE_RATIONAL:
  322.     EUCALL_1(Fn_prin_internal,form->RATIO.numerator);
  323.     fprintf(CURRENT_OUTPUT(),"/");
  324.     form = ARG_0(stackbase);
  325.     EUCALL_1(Fn_prin_internal,form->RATIO.denominator);    
  326.     break;
  327.   case TYPE_FLOAT:
  328.     {
  329.       sprintf(LINEBUFF(),"%lf",form->FLOAT.fvalue);
  330.       fputs(LINEBUFF(),CURRENT_OUTPUT());
  331.     }
  332.     break;
  333.   case TYPE_COMPLEX:
  334.     fputs("#C(",CURRENT_OUTPUT());
  335.     EUCALL_1(Fn_prin_internal,(form->COMPLEX).real);
  336.     putc(',',CURRENT_OUTPUT());
  337.     form = ARG_0(stackbase);
  338.     EUCALL_1(Fn_prin_internal,(form->COMPLEX).imaginary);
  339.     putc(')',CURRENT_OUTPUT());
  340.     break;
  341.   case TYPE_CHAR:
  342.     if (form == q_eof)
  343.       fprintf(CURRENT_OUTPUT(),"<<EOS>>");
  344.     else
  345.       putc((form->CHAR).code,CURRENT_OUTPUT());
  346.     break;
  347.   case TYPE_SYMBOL:
  348.     if (form == nil) {
  349.       fprintf(CURRENT_OUTPUT(),"()");
  350.     }
  351.     else {
  352.       fprintf(current_output,"%s",stringof((form->SYMBOL.pname)));
  353.     }
  354.     break;
  355.   case TYPE_STRING:
  356.     sprintf(LINEBUFF(),"%s",stringof(form));
  357.     fputs(LINEBUFF(),CURRENT_OUTPUT());
  358.     break;
  359.   case TYPE_CONS:
  360.     putc('(',CURRENT_OUTPUT());
  361.     EUCALL_1(Fn_prin_internal, CAR(form));
  362.     form = ARG_0(stackbase);
  363.     while (is_cons(CDR(form))) {
  364.       putc(' ',CURRENT_OUTPUT());
  365.       ARG_0(stackbase) = form = CDR(form);
  366.       EUCALL_1(Fn_prin_internal, CAR(form));
  367.       form = ARG_0(stackbase);
  368.     }
  369.     if (CDR(form) == nil) putc(')',CURRENT_OUTPUT());
  370.     else {
  371.       putc(' ',CURRENT_OUTPUT());
  372.       putc('.',CURRENT_OUTPUT());
  373.       putc(' ',CURRENT_OUTPUT());
  374.       EUCALL_1(Fn_prin_internal, CDR(form));
  375.       putc(')',CURRENT_OUTPUT());
  376.     }
  377.     break;
  378.   case TYPE_STREAM:
  379.       fprintf(CURRENT_OUTPUT(),"#<stream: %d '%c'>",
  380.           (int) (form->STREAM.handle),
  381.           (char) (form->STREAM.mode));
  382.       break;
  383.   case TYPE_VECTOR:
  384.     fputs("#(",CURRENT_OUTPUT());
  385.     {
  386.       int i;
  387.       for (i=0;i< form->VECTOR.length-1;++i) {
  388.     EUCALL_1(Fn_prin_internal,vref(form,i));
  389.     form = ARG_0(stackbase);
  390.     fputs(" ",CURRENT_OUTPUT());
  391.       }
  392.       if (form->VECTOR.length > 0)
  393.     EUCALL_1(Fn_prin_internal,vref(form,i));
  394.     }
  395.     fputs(")",CURRENT_OUTPUT());
  396.     break;
  397.   case TYPE_TABLE:
  398.     fputs("#T(",CURRENT_OUTPUT());
  399.     if ((form->TABLE).comparator == Fn_equal) fputs("equal",CURRENT_OUTPUT());
  400.     else fputs("???",CURRENT_OUTPUT());
  401.     putc(')',CURRENT_OUTPUT());
  402.     break;
  403.   case TYPE_I_FUNCTION:
  404.     {
  405.       LispObject body;
  406.       Env env;
  407.  
  408.       fputs("#<interpreted-function: (lambda ",CURRENT_OUTPUT());
  409.       EUCALL_1(Fn_prin_internal,(form->I_FUNCTION).bvl);
  410.       form = ARG_0(stackbase);
  411.       body = form->I_FUNCTION.body;
  412.       while ( body != nil ) {
  413.     fprintf(CURRENT_OUTPUT()," ");
  414.     STACK_TMP(CDR(body));
  415.     EUCALL_1(Fn_prin_internal,CAR(body));
  416.     UNSTACK_TMP(body);
  417.       }
  418.       putc(')',CURRENT_OUTPUT());
  419.  
  420.       form = ARG_0(stackbase);
  421.       for (env = form->I_FUNCTION.env; env != NULL; env = env->next) {
  422.     fprintf(CURRENT_OUTPUT()," %s=",stringof(env->variable->SYMBOL.pname));
  423.     STACK_TMPV(env);
  424.     EUCALL_1(Fn_prin_internal, env->value);
  425.     UNSTACK_TMPV(env);
  426.       }
  427.  
  428.       form = ARG_0(stackbase);
  429.       fprintf(CURRENT_OUTPUT()," @ %s>",
  430.           stringof(form->I_FUNCTION.home->I_MODULE.name->SYMBOL.pname));
  431.     }
  432.     break;
  433.   case TYPE_C_FUNCTION:
  434.     fprintf(CURRENT_OUTPUT(),"#<c-function: %x %d ",
  435.         (int) (form->C_FUNCTION.func),
  436.         form->C_FUNCTION.argtype);
  437.     if (form->C_FUNCTION.name != nil)
  438.       fprintf(CURRENT_OUTPUT(),"%s ",stringof(form->C_FUNCTION.name->SYMBOL.pname));
  439.     fprintf(CURRENT_OUTPUT(),"@ %s>",
  440.         stringof(form->C_FUNCTION.home->C_MODULE.name->SYMBOL.pname));
  441.     break;
  442.   case TYPE_C_MACRO:
  443.     fprintf(CURRENT_OUTPUT(),"#<c-macro: %x %d ",
  444.         (int) (form->C_FUNCTION.func),
  445.         form->C_FUNCTION.argtype);
  446.     if (form->C_FUNCTION.name != nil)
  447.       fprintf(CURRENT_OUTPUT(),"%s ",stringof(form->C_FUNCTION.name->SYMBOL.pname));
  448.     fprintf(CURRENT_OUTPUT(),"@ %s>",
  449.         stringof(form->C_FUNCTION.home->C_MODULE.name->SYMBOL.pname));
  450.     break;
  451.   case TYPE_I_MACRO:
  452.     fputs("#<interpreted-macro:(",CURRENT_OUTPUT());
  453.     EUCALL_1(Fn_prin_internal,(form->I_FUNCTION).bvl);
  454.     form = ARG_0(stackbase);
  455.     EUCALL_1(Fn_prin_internal,(form->I_FUNCTION).body);
  456.     putc(')',CURRENT_OUTPUT());
  457.     break;
  458.   case TYPE_SPECIAL:
  459.     fprintf(CURRENT_OUTPUT(),"#<special-form: %x '%s'>",
  460.         (int) ((form->SPECIAL).func),
  461.         stringof((form->SPECIAL).name->SYMBOL.pname));
  462.     break;
  463. #ifdef obsolete /* Tue Jul 30 13:20:19 1991 */
  464. /**/  case TYPE_GENERIC:
  465. /**/    fprintf(CURRENT_OUTPUT(),"#<%s: %d",
  466. /**/        classof(form)->CLASS.name->SYMBOL.pname,
  467. /**/        intval(generic_argtype(form)));
  468. /**/    if (generic_name(form) != nil) {
  469. /**/      fprintf(CURRENT_OUTPUT()," ");
  470. /**/      (void) Fn_prin_internal(generic_name(form));
  471. /**/    }
  472. /**/    
  473. /**/    fprintf(CURRENT_OUTPUT()," @ %s>",
  474. /**/        generic_home(form)->C_MODULE.name->SYMBOL.pname);
  475. /**/    break;
  476. /**/  case TYPE_METHOD:
  477. /**/    fprintf(CURRENT_OUTPUT(),"#<%s: ",
  478. /**/        classof(form)->CLASS.name->SYMBOL.pname);
  479. /**/    Fn_prin_internal(/*+::+*//*+:NULL:+*/method_signature(form));
  480. /**/    fprintf(CURRENT_OUTPUT()," ");
  481. /**/    Fn_prin_internal(/*+::+*//*+:NULL:+*/method_host(form));
  482. /**/
  483. /**/    fprintf(CURRENT_OUTPUT(),">");
  484. /**/    break;
  485. #endif /* obsolete Tue Jul 30 13:20:19 1991 */
  486.   case TYPE_CONTINUE:
  487.     fprintf(CURRENT_OUTPUT(), "#<continuation: %x %s>", (int) form,
  488.         (form->CONTINUE).live ? "live" : "dead");
  489.     break;
  490.   case TYPE_C_MODULE:
  491.     fprintf(CURRENT_OUTPUT(), "#<c-module: ");
  492.     EUCALL_1(Fn_prin_internal,(form->C_MODULE.name));
  493.     putc(' ',CURRENT_OUTPUT());
  494.     form = ARG_0(stackbase);
  495.     {
  496.       LispObject xx;
  497.       xx= form->C_MODULE.exported_names;
  498.       EUCALL_1(Fn_prin_internal,xx);
  499.     }
  500.     fprintf(CURRENT_OUTPUT(),">");
  501.     break;
  502.   case TYPE_I_MODULE:
  503.     fprintf(CURRENT_OUTPUT(), "#<interpreted-module: ");
  504.     EUCALL_1(Fn_prin_internal,form->I_MODULE.name);
  505.     putc(' ',CURRENT_OUTPUT());
  506.     form = ARG_0(stackbase);
  507.     EUCALL_1(Fn_prin_internal,form->I_MODULE.exported_names);
  508.     fprintf(CURRENT_OUTPUT(),">");
  509.     break;
  510.   case TYPE_ENV:
  511.     {
  512.       Env runner = (Env) form;
  513.       int i = 0;
  514.  
  515.       fputs("#<env: ",CURRENT_OUTPUT());
  516.       while (runner!=NULL) {
  517.     putc('(',CURRENT_OUTPUT());
  518.     STACK_TMPV(runner);
  519.     EUCALL_1(Fn_prin_internal,runner->variable); 
  520.     putc(' ',CURRENT_OUTPUT());
  521.     runner = (Env) *(stacktop-1);
  522.     EUCALL_1(Fn_prin_internal,runner->value); 
  523.     putc(')',CURRENT_OUTPUT());
  524.     UNSTACK_TMPV(runner);
  525.     runner = runner->next;
  526.     ++i;
  527.       }
  528.       putc('>',CURRENT_OUTPUT());
  529.     }
  530.     break;
  531.   case TYPE_THREAD:
  532.     fprintf(CURRENT_OUTPUT(),"#<thread: %x %d ",
  533.         (int) form,form->THREAD.status);
  534.     EUCALL_1(Fn_prin_internal,form->THREAD.value);
  535.     fprintf(CURRENT_OUTPUT(),">");
  536.     break;
  537.   case TYPE_SEMAPHORE:
  538.     fprintf(CURRENT_OUTPUT(),
  539.         "#<semaphore: %x,%x>",(int) form,form->SEMAPHORE.semaphore);
  540.     break;
  541.  
  542. #if (defined(WITH_BSD_SOCKETS) || defined(WITH_SYSTEMV_SOCKETS))
  543.  
  544.   case TYPE_LISTENER:
  545.     fprintf(CURRENT_OUTPUT(),"#<listener: %d %d>",
  546.         form->LISTENER.socket,
  547.         form->LISTENER.state);
  548.     break;
  549.   case TYPE_SOCKET:
  550.     fprintf(CURRENT_OUTPUT(),"#<socket: %d %d>",
  551.         form->SOCKET.socket,
  552.         form->SOCKET.state);
  553.     break;
  554.  
  555. #endif
  556.  
  557.   default:
  558.     if (classp(form) || typeof(form) == TYPE_CLASS ) {
  559.       fprintf(CURRENT_OUTPUT(),"#<%s: %s>",
  560.           stringof(CLASS_NAME(classof(form))->SYMBOL.pname),
  561.           stringof(CLASS_NAME(form)->SYMBOL.pname));
  562.     }
  563.     else
  564.       fprintf(CURRENT_OUTPUT(), "#<%s: %x>",
  565.           stringof(CLASS_NAME(classof(form))->SYMBOL.pname),(int) form);
  566.   }
  567.  
  568.   UNSTACK_TMP(ans);
  569.   return ans;
  570. }
  571. EUFUN_CLOSE
  572.  
  573. EUFUN_2( Fn_prin, form, stream)
  574. {
  575.  
  576.   if (stream==nil) stream=StdOut;
  577.   if (stream==NULL) CURRENT_OUTPUT() = (StdOut->STREAM).handle;
  578.   else CURRENT_OUTPUT() = (stream->STREAM).handle;
  579.   EUCALL_1(Fn_prin_internal,form);
  580.   CURRENT_OUTPUT() = StdOut->STREAM.handle;
  581.  
  582.   return ARG_0(stackbase);
  583. }
  584. EUFUN_CLOSE
  585.  
  586. EUFUN_1( Fn_newline, stream)
  587. {
  588.   STACK(stream);
  589.  
  590.   if (stream==NULL) CURRENT_OUTPUT() = (StdOut->STREAM).handle;
  591.   else CURRENT_OUTPUT() = (stream->STREAM).handle;
  592.   putc('\n',CURRENT_OUTPUT());
  593.   CURRENT_OUTPUT() = StdOut->STREAM.handle;
  594.  
  595.   return nil;
  596. }
  597. EUFUN_CLOSE
  598.  
  599. EUFUN_2( Fn_print, form, stream)
  600. {
  601.   if (stream==nil) stream=StdOut;
  602.   if (stream==NULL) CURRENT_OUTPUT() = (StdOut->STREAM).handle;
  603.   else CURRENT_OUTPUT() = (stream->STREAM).handle;
  604.   EUCALL_1(Fn_prin_internal, form);
  605.   putc('\n',CURRENT_OUTPUT());
  606.   CURRENT_OUTPUT() = StdOut->STREAM.handle;
  607.  
  608.   return ARG_0(stackbase);
  609. }
  610. EUFUN_CLOSE
  611.  
  612. EUFUN_2( Fn_writechar, obj, stream)
  613. {
  614.   if (stream==NULL) CURRENT_OUTPUT() = (StdOut->STREAM).handle;
  615.   else if (stream==nil) CURRENT_OUTPUT() = (StdOut->STREAM).handle;
  616.   else CURRENT_OUTPUT() = (stream->STREAM).handle;
  617.   putc((obj->CHAR).code,CURRENT_OUTPUT());
  618.   CURRENT_OUTPUT() = StdOut->STREAM.handle;
  619.   return obj;
  620. }
  621. EUFUN_CLOSE
  622.  
  623. EUFUN_2( Fn_writebyte, obj, stream)
  624. {
  625.   if (stream==NULL) CURRENT_OUTPUT() = (StdOut->STREAM).handle;
  626.   else if (stream==nil) CURRENT_OUTPUT() = (StdOut->STREAM).handle;
  627.   else CURRENT_OUTPUT() = (stream->STREAM).handle;
  628.   putc(intval(obj),CURRENT_OUTPUT());
  629.   CURRENT_OUTPUT() = StdOut->STREAM.handle;
  630.   return obj;
  631. }
  632. EUFUN_CLOSE
  633.  
  634. EUFUN_2( Fn_write_text, str, stream)
  635. {
  636.   fprintf(stream->STREAM.handle,"%s",stringof(str));
  637.   return(nil);
  638. }
  639. EUFUN_CLOSE
  640.  
  641. void initialise_output(LispObject *stacktop)
  642. {
  643.  
  644.   (void) make_module_function(stacktop,"write-char", Fn_writechar, 2);
  645.   (void) make_module_function(stacktop,"write-byte", Fn_writebyte, 2);
  646.  
  647.   (void) make_module_function(stacktop,"write-text",Fn_write_text,2);
  648.  
  649. }
  650.  
  651.  
  652.